home *** CD-ROM | disk | FTP | other *** search
/ Aminet 2 / Aminet AMIGA CDROM (1994)(Walnut Creek)[Feb 1994][W.O. 44790-1].iso / Aminet / dev / e / amigae21b.lha / Amiga_E_v2.1b / Sources / Projects / Forth.e next >
Text File  |  1992-09-02  |  4KB  |  132 lines
  1. /* TinyForth, a subset Forth interpreter
  2.    no functions *yet*, so may be used as funny calculator
  3.    with stack. exits on QUIT<cr> or <ctrlc><cr> */
  4.  
  5. CONST MAXSTACK=1000,MAXRSTACK=200
  6. ENUM NO_MES,OK,ER_UNDERFLOW,ER_OVERFLOW,ER_SYM
  7.  
  8. DEF con,stop=FALSE,error=OK,crflag=TRUE,
  9.     inp[100]:STRING,
  10.     item[50]:STRING, item2[50]:STRING,
  11.     stack[MAXSTACK]:ARRAY OF LONG, rstack[MAXRSTACK]:ARRAY OF LONG,
  12.     sp:PTR TO LONG, rsp:PTR TO LONG
  13.  
  14. PROC main()
  15.   con:=Open('CON:0/11/640/100/TinyForth',1005)
  16.   IF con
  17.     stdout:=con
  18.     WriteF('TinyForth interpreter v0.1 (c) 1992 by $#%!\n')
  19.     sp:=stack; rsp:=rstack
  20.     REPEAT
  21.       puterror()
  22.       WriteF('>')
  23.       ReadStr(con,inp)
  24.       IF CtrlC() THEN stopnow()
  25.       error:=OK; crflag:=TRUE
  26.       eval(inp)
  27.     UNTIL stop
  28.     Close(con)
  29.   ENDIF
  30. ENDPROC
  31.  
  32. PROC eval(c)
  33.   DEF pos,end,symlong,p,i,j,k
  34.   pos:=c; end:=c+EstrLen(c)
  35.   WHILE (pos<end) AND (error<=OK)
  36.     IF CtrlC() THEN stopnow()
  37.     pos:=getsym(pos)
  38.     StrCopy(item2,item,ALL)
  39.     UpperStr(item2)
  40.     StrAdd(item2,'   ',3)
  41.     symlong:=Long(item2)
  42.     SELECT symlong
  43.       CASE "DUP "; i:=pop(); push(i); push(i)
  44.       CASE "DROP"; pop()
  45.       CASE "SWAP"; i:=pop(); j:=pop(); push(i); push(j)
  46.       CASE "OVER"; i:=pop(); j:=pop(); push(j); push(i); push(j)
  47.       CASE "ROT "; i:=pop(); j:=pop(); k:=pop(); push(j); push(i); push(k)
  48.       CASE "PICK"; i:=pop(); IF sp-(i*4)<stack THEN error:=ER_UNDERFLOW ELSE push(sp[-i])
  49.       CASE "ROLL"; i:=pop(); j:=sp[-i]; IF sp-(i*4)<stack THEN error:=ER_UNDERFLOW ELSE FOR k:=-i TO -2 DO sp[k]:=sp[k+1]; pop(); push(j)
  50.       CASE "?DUP"; i:=pop(); push(i); IF i THEN push(i)
  51.       CASE "DEPT"; push(sp-stack/4)
  52.       CASE ">R  "; rpush(pop())
  53.       CASE "R>  "; push(rpop())
  54.       CASE "R@  "; i:=rpop(); push(i); rpush(i)
  55.  
  56.       CASE "<   "; push(Not(pop()<=pop()))
  57.       CASE "=   "; push(pop()=pop())
  58.       CASE ">   "; push(Not(pop()>=pop()))
  59.       CASE "0<  "; push(pop()<0)
  60.       CASE "0=  "; push(0=pop())
  61.       CASE "0>  "; push(pop()>0)
  62.       CASE "D<  "; push(Not(pop()<=pop()))
  63.       CASE "U<  "; push(Not(pop()<=pop()))
  64.       CASE "NOT "; push(Not(pop()))
  65.  
  66.       CASE ".   "; WriteF('\d ',pop()); crflag:=FALSE
  67.       CASE "CR  "; WriteF('\n'); crflag:=TRUE
  68.       CASE "EMIT"; WriteF('\c',pop()); crflag:=FALSE
  69.       CASE "TYPE"; i:=pop(); j:=pop(); FOR k:=1 TO i DO WriteF('\c',j[]++)
  70.       CASE "SPAC"; IF Long(item2+4)="E   " THEN i:=1 ELSE i:=pop(); FOR j:=1 TO i DO WriteF(' '); crflag:=FALSE
  71.  
  72.       CASE "+   "; push(pop()+pop())
  73.       CASE "-   "; i:=pop(); push(pop()-i)
  74.       CASE "*   "; push(Mul(pop(),pop()))
  75.       CASE "/   "; i:=pop(); push(Div(pop(),i))
  76.  
  77.       CASE "ABOR"; sp:=stack
  78.       CASE "QUIT"; stop:=TRUE
  79.       DEFAULT
  80.         IF Int(item)=$2E22      /* ." construction */
  81.           crflag:=FALSE
  82.           Write(stdout,item+2,EstrLen(item)-3)
  83.         ELSE
  84.           IF item[0]="-" THEN p:=item+1 ELSE p:=item
  85.           i:=Val(p,{j})
  86.           IF (j=0) THEN error:=ER_SYM
  87.           IF p<>item THEN i:=Mul(i,-1)
  88.           push(i)
  89.        ENDIF
  90.     ENDSELECT
  91.   ENDWHILE
  92. ENDPROC
  93.  
  94. PROC pop() RETURN IF sp<=stack THEN error:=ER_UNDERFLOW ELSE sp[]--
  95. PROC rpop() RETURN IF rsp<=rstack THEN error:=ER_UNDERFLOW ELSE rsp[]--
  96. PROC push(val); IF MAXSTACK*4+stack<=sp THEN error:=ER_OVERFLOW ELSE sp[]++:=val; ENDPROC
  97. PROC rpush(val); IF MAXRSTACK*4+rstack<=rsp THEN error:=ER_OVERFLOW ELSE rsp[]++:=val; ENDPROC
  98.  
  99. PROC getsym(p)
  100.   DEF p2
  101.   p:=TrimStr(p)
  102.   IF p[0]="("
  103.     p2:=InStr(p,')',0)
  104.     IF p2=-1 THEN p2:=1000
  105.     p:=TrimStr(p+p2+1)
  106.   ENDIF
  107.   IF p[0]="." AND p[1]=34
  108.     p2:=InStr(p,'"',2)
  109.     IF p2=-1 THEN p2:=1000 ELSE INC p2
  110.     StrCopy(item,p,p2)
  111.   ELSE
  112.     p2:=InStr(p,' ',0)
  113.     IF p2=-1 THEN p2:=1000
  114.     StrCopy(item,p,p2)
  115.   ENDIF
  116. ENDPROC p+p2+1
  117.  
  118. PROC puterror()
  119.   IF crflag=FALSE THEN WriteF('\n')
  120.   SELECT error
  121.     CASE OK;           WriteF('Ok.\n')
  122.     CASE ER_UNDERFLOW; WriteF('STACK UNDERFLOW.\n')
  123.     CASE ER_OVERFLOW;  WriteF('STACK OVERFLOW.\n')
  124.     CASE ER_SYM;       WriteF('\s?\n',item)
  125.   ENDSELECT
  126. ENDPROC
  127.  
  128. PROC stopnow()
  129.   Close(con)
  130.   CleanUp(0)
  131. ENDPROC
  132.